home *** CD-ROM | disk | FTP | other *** search
Text File | 1989-05-10 | 37.1 KB | 1,494 lines |
- ; COMMON.RAP -- standard interaction routines for RAP
- ; copyright 1988 SIL
- ;
- ; Gary F. Simons, SIL / Kirk Parker, SIL
- ;
- ; Version 1.01 - 10 May 1989
- ; a. #filesize now reports in Kbytes
- ; b. *get_input_file now detects non-existent files
- ; Version 1.0 - Released 10 Oct 1988
- ; previously major version: 23 September 1988 khp for RAP 0.88
- ;
- ;----------------------------------------------------------
- ;
- ; This file contains loose code, which enables it to declare some
- ; "truly" global variables and to execute some start-up code.
- ; As a result, this file is sensitive to the order in which it is loaded:
- ;
- ; 1. COMMON.RAP must be .included before all other program files that
- ; contain subroutines. It is still possible to include other files
- ; ahead of COMMON.RAP as long as those files contain only loose code
- ; and/or .define statements.
- ;
- ; 2. No file loaded after COMMON.RAP may contain loose code.
- ;
- ; While this will restrict the use of loose code by user programs, the
- ; benefits of using the subroutine library far outweigh this minor drawback.
- ; Note that using a main subroutine results in a better-documented program
- ; anyway!
-
- .define .LOCALMATCH declare $left,$match,$right
- .define .BELL t:*chr(7)\
- .define .YES 1
- .define .NO 0
-
- ; return values from *existf:
-
- .define .NOTFOUND 0
- .define .READWRITE 2
- .define .READONLY 4
-
- .define .MININT (-2147483639)
- .define .MAXINT 2147483639
-
- ; longest allowed slashcode:
-
- .define .MAXCODE 78
-
- ; valid filename chars:
-
- .define .FILECHARS a-z0-9_A-Z!@#$%^&()'`{}~\-
-
- ; 0 - (amount of extra space desired) for ensure_space
-
- .define .HEADROOM -10240
-
- ;----------------------------------------------------------
- ; the following variables must be declared at the global level
- ; this group is documented as accessible to the user:
-
- #verbose=1 ; are explanations enabled? default = yes
-
- if ($screentype == "Sharp LCD") ; inter-line spacing for query routines
- $skip=$null
- else
- $skip=$newline*chr(13)
- endif
-
- $valdr=*getdr__() ; list of valid disk drives
-
- ; this group is non-documented and for internal use only
-
- #help__= -1 ; help-file descriptor. default = help file not opened
- ; help file name for closing/reopening (default = none)
- $helpfile__=
- $dospath__=$path ; save original PATH so we can access it from library
- ; routines even if caller changes $path
-
- ;------------------------------------------------------------
- ; error
- ;
- ; effect: Sound the alarm and display an error message. If help
- ; is available, tell the user about it.
- ;
- ; inputs: $message the message to display
- ; $topic the help topic pertinent to the question that
- ; was answered incorrectly
- ;
-
- proc error($message,$topic)
-
- declare $tag,$indent
- .LOCALMATCH
-
- ; add a period to message if needed
- if (not ($message contains "[.!?]$"))
- $message=$message.
- endif
-
- if ($message contains "^[ \\t][ \\t]*") ; we want the side effect only
- $indent=$match
- endif
-
- t:$skip*chr(7)$message\
-
- if ($topic == "")
- $tag=Try again.
- else
- $tag=Try again. (Type ? for help.)
- endif
-
- ; terminate line if tag won't fit, indent next line same as message
-
- if ((*strlen($message) + *strlen($tag)) > 72)
- t:
- t:$indent\
- else
- t: \
- endif
-
- t:$tag
-
- endproc
-
- ; ----------------------------------------------------------
- ; warning
- ;
- ; effect: Ring alarm and display message. wait until user enters RETURN
- ;
-
- proc warning($message)
-
- if (not $message has "\\.?!$")
- $message=$message.
- endif
-
- t:$skip*chr(7)$message.
-
- kbflush()
- foot
-
- endproc
-
- ;------------------------------------------------------------
- ; mount
- ;
- ; effect: Ensure that the needed disk volume is mounted by waiting
- ; for it to be mounted if it is not mounted already.
- ;
- ; inputs: $drive The one-letter designator of the drive
- ; $id The volume id of the disk that needs to be mounted
- ; $name The diskette name to be used in a prompt if the
- ; volume is not already mounted
- ;
-
- proc mount_volume($drive,$id,$name,$topic)
-
- declare $volname,#fd,#case,#opentest,#reopen_help
-
- loop
-
- $volname=*volume($drive)
- exit if ($volname == $id)
-
- ; ensure that there are no open files. It's not safe to change the disk
- ; if there's any chance of an open output file.
-
- if (not #opentest) ; if we haven't already tested for open files
- #opentest = 1
- #fd = *open("nul")
- close #fd
-
- if (#fd > 1 or (#fd > 0 and #help__ == -1))
- t:*chr(7)
- t:The program needs to change disks so that the $name
- t:disk is accessible, but it is not safe to do so because the program has
- t:one or more files open.
- t:
-
- if ($topic <> "")
- explain($topic)
- else
- t: The program must terminate immediately. Please report this
- t: message to the program's author.
- endif
- foot
- bye
- endif
- endif
- if (#help__ >= 0)
- close #help__
- #help__ = -1
- #reopen_help = 1
- endif
-
- t:$skip\Put the $name disk in drive $drive.
- kbflush()
- foot:Press RETURN after you have done this.
-
- endloop
-
- if (#reopen_help)
- reopen_help__()
- endif
-
- endproc
-
-
- ; ----------------------------------------------------------
- proc panic__($location,$msg) ; for internal error messages only
-
- declare #paged
-
- t:*chr(7)$skip\Internal error in \*$location:
- t:
- t: $msg
- t:
- t:The program will continue to run, but the results may not be valid.
- t:Copy this message exactly, so you can report it to the program's author,
- t:and exit as soon as possible. You may exit immediately by typing
- t:Ctrl-C.
- kbflush()
- foot
- endproc
-
- ; ----------------------------------------------------------
- proc kbflush()
-
- declare $junk
-
- loop while (*keypress())
- as $junk
- endloop
-
- endproc
-
- ; ----------------------------------------------------------
- ; getdr
- ;
- ; effect: assemble list of valid drive designators and return as string
- ;
- ; globals used: $cmdline
-
- strfunc getdr__()
-
- declare $drvlist,$tmp,#case,#tmp
- .LOCALMATCH
-
- ; look for /drive=LIST... on command line
-
- if ($cmdline contains "[-/]drive=[ \\t]*")
- $drvlist=$right
- if ($drvlist contains "[ \\t]")
- $drvlist=$left
- endif
- return $drvlist
- endif
-
- if ($screentype == "Sharp LCD")
-
- if (*freesp("P") == -1)
- return "ABCDG"
- else
- return "ABCDGP"
- endif
-
- else ; it's not a Sharp
-
- $drvlist=AB
- $tmp=C
-
- loop while (*freesp($tmp) > 0)
- $drvlist=$drvlist$tmp
- #tmp = *ascii($tmp) + 1
- $tmp=*chr(#tmp)
- endloop
-
- return $drvlist
-
- endif
-
- endfunc
-
- ;----------------------------------------------------------
- ; explain - display help-file information. *Explain assumes the help-file is
- ; already open with the file descriptor in the global variable
- ; #help. It also tests the global variable #verbose which is 1 to
- ; enable explanations and 0 to disable. Note that some routines
- ; (e.g. *get_ans) declare a local copy of #verbose that is set to 1,
- ; thus enabling explanation on a local basis.
- ;
- ; A help-file has the following format:
- ; \id line
- ; [size line - if this line contains an int, set #fscale to its value]
- ; zero or more index lines in the format topic_name: offset (in bytes)
- ; zero or more topic entries beginning with \text topic_name
- ;
- ; *explain recognizes the following standard format markers in the help-file:
- ;
- ; \text - beginning of a topic
- ; \cls - execute a ch: command
- ; \foot - execute a foot command
- ;
- ; It may also recognize the following marker(s) in the near future:
- ;
- ; \more - like foot, but allows the user to choose between reading more or
- ; exiting explain (this is similar to the way HELP works in ED.)
- ; ----------------------------------------------------------
-
- proc explain($topic)
-
- declare #case,$line
- .LOCALMATCH
-
- if (not #verbose) ; explanations are turned off
- return
- else if (#help__ < 0)
- t:There is no help-file available to this program.
- foot ; ensure the user sees the message
- return
- endif
-
- seek #help__,2 ; skip \id line
-
- ; look for $topic in index - try to match a colon on each line. If no match,
- ; we're at the end of the index. otherwise, $left contains the name
- ; and $right contains the index.
-
-
- loop while ($line <> "End of file.")
- read #help__,$line
- exit if (not ($line contains ":"))
- exit if ($left == $topic)
- endloop
-
- if ($line == "End of file." or $left <> $topic)
- t:Sorry, there is no information on <$topic> in the help file.
- foot
- return
- endif
-
- seek #help__,*value($right),bytes
- loop
- read #help__,$line
- exit if ($line == "End of file.")
- if (not ($line has "^\\\\")) ; no format marker
- t:$line ; so just display the line
- else if ($line=="\\cls")
- cls
- else if ($line=="\\foot")
- foot
- ; else if ($line=="\\more")
- ; exit if (not *more())
- else if ($line has "^\\\\topic[ \\t]")
- exit
- else ; it's not a marker we recognize - just display it.
- t:$line
- endif
- endloop
- endproc
-
- ; ----------------------------------------------------------
- ;
- ;get_filespec
- ;
- ; changes: revised to call get_ans
- ; put . in ext
- ;
- ;effect: Get a valid drive, subdirectory, name, and extension.
- ; Give help on ? and display directory on dir.
- ;
- ;inputs: $query the query prompt to be displayed
- ; $defpath default drive and subdirectory
- ; $defname default file name (without extension)
- ; $defext default file extension
- ; $topic help topic
- ;
- ;returns: valid filespec
- ; parsed filespec in four (global) variables:
- ; $drive, $subdir, $name, $ext
- ;
-
- strfunc get_filespec($query,$defpath,$defname,$defext,$topic)
-
- declare $answer,$left,$match,$right,#case,$default,$defdrive
-
- $drive=
- $subdir=
- $name=
- $ext=
-
- $defext=*ensure_dot($defext)
- if ($defpath <> "") ; append \ if default path not blank
- if (not ($defpath has "[:\\\\]$")) ; and doesn't end with : or \
- $defpath=$defpath\\
- endif
- endif
-
- $default=$defname$defext
-
- if ($default <> "")
- $query=$query [$default]
- endif
-
- loop
- $answer=*get_ans("$query (type DIR for directory):","",$topic,not +
- *strlen($default))
- if (($answer == "") and ($default == $defext))
- error(" Your answer must always include a filename part.",$topic)
- repeat
- else if ($answer == "")
- $answer=$defpath$defname$defext
- else if ($answer contains "^[ \\t]*dir\[ \\t]*")
- show_dir__($right,$defpath,$defext)
- repeat
- endif
-
- if (not ($answer has "[\\\\:]")) ;add default path if user gave none
- $answer=$defpath$answer
- endif
-
- if (*parse_filespec($answer,.YES,$topic))
- if ($ext == "")
- $ext=$defext
- endif
- return "$drive$subdir$name$ext"
- endif
-
- endloop
-
- endfunc
- ; ----------------------------------------------------------
- ;
- ;get_input_file
- ;
- ; effect: Get the name of an existing file for input. Give help on ?
- ; and display directory on dir. Force renaming if the
- ; requested input file has .TMP or .BAK extension. Also
- ; returns parsed filespec in four global variables listed below.
- ;
- ; inputs: $query the query prompt to be displayed
- ; $defpath default drive and subdirectory
- ; $defname default file name (without extension)
- ; $defext default file extension
- ; $topic help topic
- ;
- ; returns: filespec of a file which exists
- ; size (in kilobytes) of the file in global #filesize
- ;
- ;modifies: Returns parsed filespec in:
- ; $drive, $subdir, $name, $ext
- ;
-
- strfunc get_input_file($query,$defpath,$defname,$defext,$topic)
-
- declare #case,#verbose,$filespec
- declare $oldname ;hold .BAK or .TMP name to be changed
-
- #verbose=1 ; ensure that explain() will explain
-
- loop
-
- $filespec=*get_filespec($query,$defpath,$defname,$defext,$topic)
-
- #filesize=*filesize($filespec) ;return its size
-
- if (#filesize < 0)
- error(" $filespec does not exist.",$topic)
- else
- #filesize = (#filesize + 1023) / 1024
- if (($ext == ".TMP") or ($ext == ".BAK")) ;rename if TMP or BAK file
- t:*chr(7)An input file may not have a TMP or BAK extension.
- repeat if (*no("Do you want to rename the file to a different+
- extension","",""))
-
- $oldname=$filespec
- loop
- $ext=*get_str("New extension for $oldname","","",1,4,.YES)
- $ext=*ensure_dot($ext)
- $filespec=$drive$subdir$name$ext
-
- if (not *val_ext($ext,$topic))
- repeat
- else if (($ext == ".TMP") or ($ext == ".BAK"))
- error(" You must rename the extension to something besides TMP or BAK.",$topic)
- else if (not *existf($filespec))
- exit
- endif
-
- t:*chr(7)$filespec already exists. Try a different extension.
- endloop
- xs ren $oldname $name$ext
- endif
-
- return $filespec
- endif
- endloop
-
- endfunc
-
- ; ----------------------------------------------------------
- ;
- ;get_output_file
- ;
- ; effect: Get the name of a valid file for output, verifying overwrite
- ; and ensuring sufficient space remains on device. Give help
- ; on ? and display directory on dir. Also returns parsed
- ; filespec in four global variables listed below.
- ;
- ; inputs: $query the query prompt to be displayed
- ; $defpath default drive and subdirectory
- ; $defname default file name (without extension)
- ; $defext default file extension
- ; $topic help topic
- ; #size size required (in kilobytes). 0, if no requirement.
- ;
- ; returns: filespec of a valid file on drive with sufficient space
- ;
- ;modifies: Returns parsed filespec in:
- ; $drive, $subdir, $name, $ext
- ;
-
- strfunc get_output_file($query,$defpath,$defname,$defext,$topic,#size)
-
- declare $filespec,#case
-
- loop
-
- $filespec=*get_filespec($query,$defpath,$defname,$defext,$topic)
-
- if (*delq($filespec) <> .READONLY) ; Verify overwrite if file exists
- ensure_space($drive,$subdir,#size)
- return $filespec
- endif
-
- endloop
-
- endfunc
-
- ;------------------------------------------------------------
- ;
- ;ensure_space
- ;
- ;effect: Ensures that there is adequate space for the estimated
- ; output file size by having user delete files if necessary.
- ;
- ;inputs: $drive The drive on which output file is to be written
- ; $subdir dir path where output file is to be written
- ; #size The estimated size requirement
- ;
- ; BUG: note that this subr will allow the user to delete a file which was
- ; previously validated as existing by *get_input_file.
-
- proc ensure_space($dr,$subdir,#size)
-
- declare #need ;The number of K we need to reclaim
- declare $spare ;Presentation form of space to spare
- declare $delname
- declare $path
- declare $name,$ext ; local names to trap global ones used by get_filespec
- declare $drive
- declare #attr ; result of trying to delete file
-
- if (#size < 1) ; don't check for space
- return
- else if ($dr == "")
- $dr=*currdriv():
- else
- $dr=*to_upper("*mid($dr,1,1)"):
- endif
-
- loop
- #need=#size-(*freesp($dr)/1024)
- exit if (#need < .HEADROOM) ;we've got enough to spare
-
- if (#need > 0) ;we have fewer free K than needed
- .BELL
- t:
- t:There is not enough space for the output file on drive $dr.
- t:You need to reclaim at least #need\K of space before proceeding.
-
- else ;we are borderline -- give user the option
- if (#need == 0)
- $spare=absolutely no space
- else
- #need = (0 - #need)
- $spare=only #need\K
- endif
- .BELL
- t:
- t:Your output file will probably fit on drive $dr, but there is
- t:$spare to spare. If there is a possibility that the output file
- t:will grow, it would be wise to make some extra space for the +
- output file.
-
- exit if (*no("Do you want to pause to delete some files","y",""))
-
- endif ;if we fall through here, the user either has to
- ;or wants to delete some files
-
- xs dir $dr$subdir /w /p
-
- get_filespec("File to delete","$dr$subdir","","","")
-
- if (*to_upper($dr) <> *to_upper($drive))
- error(" You must delete files on drive *to_upper($dr).","")
- else
- $delname=$dr$subdir$name$ext
- #attr = *deletef($delname)
- if (#attr == .NOTFOUND)
- t:File $delname not found.
- else if (#attr == .READONLY)
- t:File $delname is read-only and can't be deleted.
- endif
- endif
- endloop
-
- endproc
-
- ; ----------------------------------------------------------
- ;
- ;make_tmp_output
- ;
- ;effect: Create a .TMP file name based on the filename given as an
- ; input parameter, and insure that there is sufficient
- ; space
- ;
- ;inputs: $name the base filename
- ; #size size required (in kilobytes). 0, if no requirement.
- ;
- ;returns: name of corresponding TMP file on a drive with sufficient space
- ;
- ;assumes: $name does not have TMP extension already. This is ensured
- ; by always calling get_input_file before this procedure.
-
-
- strfunc make_tmp_output($file,#size)
-
- declare $left,$right,$match,#case,$path
- declare $drive
-
- if ($file contains "\\.[^\\.\\\\]*$")
- $file=$left.TMP
- else
- $file=$file.TMP
- endif
-
- if ($file contains ":")
- $drive=$left
- else
- $drive=
- endif
-
- if (*deletef($file) == .READONLY) ; a .TMP file can be overwritten
- ; without asking
- panic__("make_tmp_output","Need to delete $file but it's read-only")
- endif
-
- ensure_space($drive,"",#size)
-
- return $file
-
- endfunc
-
- ;-----------------------------------------------------------
- ;make_bak_file
- ;
- ;effect: Renames the $new file to the $old file name, and changes
- ; the $old file to a .BAK file.
- ;
- ;inputs: $oldname The original filespec of the file to be .BAKed
- ; $tmpname Filespec of the (TMP) file which is to get $oldname
- ;
- ;assumes: $oldname does not have .BAK extension. This is ensured by calling
- ; get_input_file originally to get the input filespec.
-
-
- proc make_bak_file($oldname,$tmpname)
-
- declare $left,$match,$right,#case
- declare $bak ;filespec for BAK file
-
- if ($oldname contains "\\.[^\\.\\\\]*$") ;find the LAST dot on the line
- $bak=$left.BAK
- else
- $bak=$oldname.BAK
- endif
-
- if (*deletef($bak) == .READONLY)
- panic__("make_bak_file","need to delete $bak but it's read-only")
- else
- xs ren $oldname *.BAK
-
- if ($oldname contains "[^:\\\\]*$")
- xs ren $tmpname $match
- else
- warning("Couldn't rename $tmpname to $oldname")
- endif
- endif
-
- endproc
-
- ;-----------------------------------------------------------
- ;make_bak_to_bat
- ;
- ;effect: generate batch file commands to rename $new to $old and
- ; $old to a .BAK file.
- ;
- ;inputs: $oldname The original filespec of the file to be .BAKed
- ; $tmpname Filespec of the (TMP) file which is to get $oldname
- ;
- ;assumes: $oldname does not have .BAK extension. This is ensured by calling
- ; get_input_file originally to get the input filespec.
-
-
- proc make_bak_to_bat($oldname,$tmpname,#bat)
-
- declare $left,$match,$right,#case
- declare $bak ;filespec for BAK file
-
- if ($oldname contains "\\.[^\\.\\\\]*$") ;find the LAST dot on the line
- $bak=$left.BAK
- else
- $bak=$oldname.BAK
- endif
-
- wr #bat,if exist $bak del $bak
- wr #bat,if exist $oldname ren $oldname *.bak
- if ($oldname contains "[^:\\\\]*$")
- wr #bat,if exist $tmpname ren $tmpname $match
- else
- warning("Couldn't rename $tmpname to $oldname")
- endif
-
- endproc
-
- ; ----------------------------------------------------------
- ; prepend dot (if needed) to non-blank file extension
-
- strfunc ensure_dot($ext)
-
- if ($ext <> "")
- if (*mid($ext,1,1) <> ".")
- $ext=.$ext
- endif
- endif
-
- return $ext
-
- endfunc
-
- ; ----------------------------------------------------------
- ; val_ext - validate filaname extension
- ;
- ; entry: extension in $file (param)
- ; help-topic in $topic
- ;
- ; returns: 1 if valid, 0 if invalid
- ; displays: error message for invalid conditions
-
- numfunc val_ext($ext,$topic)
-
- declare $left,$match,$right
-
- ; 1: valid ext, 2: dot only (also valid), 3: no dot
-
- if ($ext == "")
- return (.YES)
- else if ($ext has "^\\.[.FILECHARS]*$")
- if (*strlen($match) > 4) ; length = 4 to allow for dot
- error(" No more than 3 characters in extension.",$topic)
- else
- return (.YES)
- endif
- else
- error(" Extension contains invalid characters",$topic)
- return (.NO)
- endif
-
- endfunc
- ; ----------------------------------------------------------
- ; val_dir
- ;
- ; validate subdirectory name(s)
- ;
- ; input: partial path name in $file
- ; help topic in $topic
- ;
- ; returns: 1 for valid, 0 for invalid
- ;
- ; displays: appropriate error messages
-
- numfunc val_dir($subdir,$topic)
-
- .LOCALMATCH
-
- if ($subdir == "" or ($subdir contains "^[\\\\\\..FILECHARS][\\\\\\..FILECHARS]*$"))
- return (.YES)
- else if (*index($subdir,"/"))
- error(" Path names use \\, not /.",$topic)
- else if ($subdir has "[^\\\\\\.]\\." or $subdir has "\\.[^\\\\\\.]" or $subdir has "\\.\\.\\.")
- error(" Dots in subdirectories cannot be mixed with other +
- characters.",$topic)
- else
- error(" Subdirectory name(s) include invalid characters",$topic)
- endif
- return (.NO)
-
- endfunc
-
- ; ----------------------------------------------------------
- ; val_drive
- ;
- ; validate drive designator
- ;
- ; input: drive in $drive
- ; help topic in $topic
- ;
- ; returns: 1 if valid, 0 if invalid
- ;
- ; displays: error messages if needed
-
- numfunc val_drive($drive,$topic)
-
- declare #case
-
- ; match values: 1 = valid letter followed by colon, 2 = any other colon
-
- if ($drive has "^[$valdr]:$")
- return .YES
- else if ($drive has "^.:$")
- error(" Drive *to_upper($drive) does not exist.",$topic)
- else if (*index($drive,":"))
- error(" Cannot use *to_upper($drive) - must be a disk drive",$topic)
- else
- error(" Invalid drive designator: $drive",$topic)
- endif
-
- return (.NO)
-
- endfunc
-
- ; ----------------------------------------------------------
- ; delq
- ;
- ; effect: query user before deleting existing file
- ;
- ; returns: .YES if the file was deleted
- ; .NO if the file doesn't exist
- ; .INVALID if file is read_only or if user says not to delete
- ;
- ; Note that .YES and .NO both mean that the named file no longer exists,
- ; implying a new file of that name can be created. Normally, the
- ; significant return value from this subr is .INVALID, which indicates the
- ; named file exists, but the user doesn't want to delete/overwrite it, or
- ; that it is a read-only file.
-
- numfunc delq($filespec)
-
- declare $path,#attrib
-
- #attrib = *existf($filespec)
-
- if (#attrib == .NOTFOUND)
- return (.NOTFOUND)
- else if (#attrib == .READONLY)
- t:*chr(7)$filespec already exists and can't be deleted.
- return (.READONLY)
- else
- t:*chr(7)$filespec already exists. \
- kbflush()
- if (*yes("Do you want to overwrite it","",""))
- killf $filespec
- return (.READWRITE)
- else
- return (.READONLY)
- endif
- endif
-
- endfunc
-
- ; ----------------------------------------------------------
- ; delete file if possible, without informing user. Prevents RAP from
- ; trying to delete a read-only or non-existent file (which will halt the
- ; current RAP program and return to the RAP immediate mode!)
-
- numfunc deletef($file)
-
- declare $path,#attr
-
- #attr = *existf($file)
-
- if (#attr == .READONLY)
- return (.READONLY)
- else if (#attr == .READWRITE or #attr == 1)
- killf $file
- return (.READWRITE)
- else
- return (.NOTFOUND)
- endif
- endfunc
-
- ;------------------------------------------------------------
- ; get_ans
- ;
- ; effect: Ask a question, displaying a default response if any,
- ; and return the user's response. If the user requests
- ; help (by typing ? or help), give help.
- ;
- ; inputs: $query the question to ask
- ; $default the default response (null if none)
- ; $topic the help topic (null if none)
- ; #oblig 0 if null response allowed, 1 if not allowed
- ;
- ; add maxlen - to allow subr to reserve enough space on-screen.
- ;
- ; returns: the user's response as a string
-
- strfunc get_ans($query,$default,$topic,#oblig)
-
- declare $answer, $prompt, #verbose
-
- #verbose = 1
-
- ; if ((#oblig) and ($default <> ""))
- ; panic__("get_ans","default and obligatory both given")
- ; endif
-
- if (not ($query has "[?:]$"))
- $query=$query?
- endif
-
- if ($default <> "")
- $query=$query [$default]
- endif
-
- loop
- t:$skip$query \
- a:$answer
-
- if ($answer == "")
- if (#oblig and $default == "")
- error(" This question requires an answer.",$topic)
- else
- return $default
- endif
-
- else if ($answer == "?")
- if ($topic <> "")
- explain($topic)
- else
- error(" There is no help for this question.","")
- endif
- else
- return $answer
- endif
- endloop
-
- endfunc
-
- ; ----------------------------------------------------------
- ; ask y/n question with default - return 1 if yes, 0 if no
- ; if $default is "" then force y or n answer
- ; call explanation routine if $topic <> ""
-
- numfunc yes($query,$default,$topic)
-
- declare $answer,#case
-
- loop
- $answer=*get_ans($query,$default,$topic,not *strlen($default))
-
- $answer=*trim($answer)
- if (($answer == "y") or ($answer == "yes"))
- return(1)
- else if (($answer == "n") or ($answer == "no"))
- return(0)
- else
- error(" Please type yes or no.",$topic)
- endif
-
- endloop
-
- endfunc
-
- ; ----------------------------------------------------------
- ; ask y/n question, return 1=no, 0=yes, if $default=="", then force y/n
- ; this subr just passes on to *yes and then complements its return
-
- numfunc no($query,$default,$topic)
-
- return (not *yes($query,$default,$topic))
-
- endfunc
-
- ; -------------------------------------------------------
- ; read string with default, and min and max length limits.
- ; if min limit == 0, then force a non-blank response
-
-
- strfunc get_str($query,$default,$topic,#minlen,#maxlen,#oblig)
-
- declare $answer,#len
-
- ; if ((#oblig) and ($default <> ""))
- ; panic__("get_str","default and obligatory both given")
- ; #oblig = 0
- ; endif
-
- if (#minlen > #maxlen)
- panic__("get_str","minimum length is greater than maximum length")
- #minlen = 0
- endif
- if (#maxlen < 1)
- panic__("get_str","maximum length of zero")
- #maxlen = 78
- endif
-
- loop
- $answer=*get_ans($query,$default,$topic,#oblig)
- ; if ($answer == $default)
- ; return $answer
- ; endif
- #len = *strlen($answer)
- if (#len < #minlen)
- error(" Answer too short - must be at least #minlen characters.",$topic)
- else if (#len > #maxlen)
- error(" Answer too long - must be #maxlen characters or less.",$topic)
- else
- return $answer
- endif
- endloop
-
- endfunc
-
- ; -------------------------------------------------------
- ; get_code
- ;
- ; effect: Get a slashcode from the user. Returned value is validated
- ; as being alphanumeric and not containing the backslash.
- ; Returns the default value if user hits RETURN.
- ;
- ; inputs: $query The prompt query to be displayed
- ; $default The default value. "" if none.
- ; $topic Help topic
- ; #maxlen maximum number of chars in code
- ;
- ; returns: an alphanumeric string without initial backslash
-
- strfunc get_code($query,$default,$topic,#minlen,#maxlen)
-
- declare $answer,$left,$right,$match,#case
-
- if (#maxlen > .MAXCODE)
- #maxlen = .MAXCODE
- endif
-
- if ($default <> "")
- if ($default contains "^\\\\\\\\*")
- $default=\\$right
- else
- $default=\\$default
- endif
- endif
-
- loop
- $answer=*get_str("$query",$default,$topic,#minlen,#maxlen+1,#minlen)
-
- $answer=*trim($answer)
-
- if ($answer contains "^\\\\*")
- $answer=$right
- endif
-
- if (not ($answer has "^[a-z0-9_]*$"))
- error(" Slash code may contain only letters, digits, and _.",$topic)
- else if (*strlen($answer) < #minlen)
- error(" Code is too short - must be at least #minlen characters (not including \\).",$topic)
- else if (*strlen($answer) > #maxlen)
- error(" Code is too long - must be no more than #maxlen characters.",$topic)
- else
- return $answer
- endif
- endloop
-
- endfunc
-
- ; -------------------------------------------------------
- ; get a numeric answer and force to be within limits
-
- numfunc get_num($query,$default,$topic,#min,#max) ; NOTE default is string var!
-
- declare $string,#number
-
- if ($default <> "")
- if (not *isnumber($default))
- panic__("getnum","default value is not a number")
- $default=
- endif
- endif
-
- if (#min > #max)
- panic__("getnum","minimum is greater than maximum")
- #min = .MININT
- #max = .MAXINT
- endif
-
- loop
- $string=*get_ans($query,$default,$topic,not *strlen($default))
-
- if (*isnumber($string))
- #number = *value($string)
- if ((#number >= #min) and (#number <= #max))
- return (#number)
- endif
- endif
-
- error(" Please enter a number between #min and #max.",$topic)
-
- endloop
-
- endfunc
-
- ;------------------------------------------------------------
- ; to_lower
- ;
- ; effect: Converts all upper case characters in a string to lower case
- ;
- ; inputs: $source the string to convert
- ; returns: an equivalent string with upper case changed to lower
- ;
-
- strfunc to_lower($source)
-
- .LOCALMATCH
- declare #case
- #case=1 ;use case-sensitive matching
-
- loop while ($source contains "[A-Z]")
- $source=$left*chr(*ascii($match)+32)$right
- endloop
-
- return $source
-
- endfunc
-
- ;------------------------------------------------------------
- ; to_upper
- ;
- ; effect: Converts all lower case characters in a string to upper case
- ;
- ; inputs: $source the string to convert
- ; returns: an equivalent string with lower case changed to upper
- ;
-
- strfunc to_upper($source)
-
- .LOCALMATCH
- declare #case
- #case=1 ;use case-sensitive matching
-
- loop while ($source contains "[a-z]")
- $source=$left*chr(*ascii($match)-32)$right
- endloop
-
- return $source
-
- endfunc
-
- ; ----------------------------------------------------------
- ; trim - strip leading and trailing blanks from arg
-
- strfunc trim($source)
-
- declare $left,$match,$right
-
- if ($source contains "^[ \\t][ \\t]*") ;trim leading blanks
- $source=$right
- endif
- if ($source contains "[ \\t][ \\t]*$") ; trim trailing blanks
- $source=$left
- endif
-
- return $source
- endfunc
-
- ; ----------------------------------------------------------
- ;
- proc show_dir__($spec,$defpath,$defext)
-
- if ($spec <> "")
- xs dir $spec
- else
- if ($defext <> "")
- $defext=*ensure_dot($defext)
- $defext=*$defext
- endif
- if ($defpath <> "")
- if (not ($defpath has "[:\\\\]$"))
- $defpath=$defpath\\
- endif
- endif
- xs dir $defpath$defext /w
- endif
- foot
- endproc
-
- ; ----------------------------------------------------------
- ; parse_filespec
-
- numfunc parse_filespec($filespec,#report,$topic)
-
- $drive=
- $subdir=
- $name=
- $ext=
-
- if ($filespec contains ":")
- ; if (#report)
- ; t:parsed drive <$match> from <$right>
- ; endif
- $drive=$left:
- $filespec=$right
- if (#report)
- if (not *val_drive($drive,$topic))
- return (0)
- endif
- else if (not ($drive has "^[$valdr]:$))
- return (0)
- endif
- endif
-
- if ($filespec contains "\\.[^\\.\\\\]*$")
- ; if (#report)
- ; t:parsed ext <$match> from <$left>
- ; endif
- if (*strlen($match) > 4)
- if (#report)
- error(" Extension is too long",$topic)
- endif
- return (0)
- else if ($match has "[^\\..FILECHARS]")
- if (#report)
- error(" Invalid character(s) in extension.",$topic)
- endif
- return (0)
- endif
- $ext=$match
- $filespec=$left
- endif
-
- if ($filespec has "[^\\\\\\.]\\." or $filespec has "\\.[^\\\\\\.]" or $filespec has "\\.\\.\\.")
- if (#report)
- error(" Invalid dots in pathname (only . and .. are valid).",$topic)
- endif
- return (0)
- endif
-
- if ($filespec has "[^.FILECHARS\\.\\\\]")
- if (#report)
- error(" Invalid character(s) in subdirectory or filename.",$topic)
- endif
- return (0)
- endif
-
- if ($filespec contains "[^\\\\\\.][^\\\\\\.]*$")
- ; if (#report)
- ; t:parsed name <$match> from dir <$left> and extraneous text <$right>
- ; endif
- $name=$match
- $filespec=$left
- $subdir=$left
- else
- if (#report)
- error(" Filename is missing.",$topic)
- endif
- return (0)
- endif
-
- return (1)
-
- endfunc
-
- ; ----------------------------------------------------------
- ; open_help open help file, saving descriptor and name in "hidden" vars
- ;
- proc open_help($helpfile)
-
- loop while (not *existf($helpfile))
- t:*chr(7)The program's help file ($helpfile) cannot be found. At this point you may:
- t:
- menu
- option enter the correct location (drive and directory) for the help file.
- $helpfile=*get_str("Help-file location","","",0,64,0)
- option continue without on-line help available
- return
- option quit the program now
- if (*yes("Are you sure you want to quit","",""))
- bye
- endif
- endmenu
- endloop
-
- #help__ = *open($helpfile)
- $helpfile__=*findpath($helpfile)
- return
-
- endproc
-
- ; ----------------------------------------------------------
- ; get_append_file
-
- strfunc get_append_file($query,$defpath,$defname,$defext,$topic)
-
- declare #case,#verbose,$filespec,$path
- declare $oldname ; hold .BAK or .TMP name to be changed
- declare #attrib,#file ; for creating file if doesn't exist
-
- #verbose=1 ; ensure that explain() will explain
-
- loop
-
- $filespec=*get_filespec($query,$defpath,$defname,$defext,$topic)
-
- #attrib = *existf($filespec)
-
- if (#attrib == .READONLY)
- error(" $name$ext is read-only. You must use a different file.",$topic)
- repeat
- else if (#attrib == .NOTFOUND)
- #file = *open($filespec,"w")
- close #file
- endif
-
- #filesize=(*filesize($filespec)+1023)/1024 ;return its size
-
- if (($ext <> ".TMP") and ($ext <> ".BAK"))
- exit
- else ;rename if TMP or BAK file
- t:*chr(7)An "append" file may not have a TMP or BAK extension.
- repeat if (*no("Do you want to rename the file to a different extension","",""))
-
- $oldname=$filespec
- loop
- $ext=*get_str("New extension for $oldname","","",1,4,.YES)
- $ext=*ensure_dot($ext)
- $filespec=$drive$subdir$name$ext
-
- if (not *val_ext($ext,$topic))
- repeat
- else if (($ext == ".TMP") or ($ext == ".BAK"))
- error(" You must rename the extension to something besides TMP or BAK.",$topic)
- else if (not *existf($filespec))
- exit
- endif
-
- t:*chr(7)$filespec already exists. Try a different extension.
- endloop
- xs ren $oldname $name$ext
- $filespec=$drive$subdir$name$ext
- exit
- endif
- endloop
-
- return $filespec
-
- endfunc
-
- ; ----------------------------------------------------------
- ; get_fixed_output
-
- strfunc get_fixed_output($filespec,#size,#allow_sub,$query,$topic)
-
- declare $path
-
- if (*deletef($filespec) == .READONLY)
- if (not #allow_sub)
- t:*chr(7)
- t:This program needs to create an output file named $filespec,
- t:but there is an existing file with that name that is read-only.
- t:
- if ($topic <> "")
- explain($topic)
- else
- t:You must rename or delete the existing copy of
- t:$filespec and then rerun this program.
- endif
- foot
- bye
- else if (not *parse_filespec($filespec,.NO,""))
- panic__("get_fixed_output","invalid filespec ($filespec)")
- endif
- $filespec=*get_output_file($query,"$drive$subdir","",$ext,$topic,#size)
- endif
- return $filespec
-
- endfunc
-
- ; ----------------------------------------------------------
- ; mount_program ensure the named program is accessible via PATH
-
- proc mount_program($filespec,$topic)
-
- mount_file__($filespec,.YES,$topic)
-
- endproc
-
- ; ----------------------------------------------------------
- ; mount_file__ ensure named file is accessible
-
- proc mount_file__($filespec,#is_prog,$topic)
-
- declare $path,#nullfile,#reopen_help,$program
-
- if (#is_prog)
- $path=$dospath__
- $program=program$blank
- endif
-
- #nullfile = -2
-
- loop while (not *existf($filespec))
- t:
- if (#nullfile < -1)
- t:*chr(7)\
- #nullfile = *open("nul")
- close #nullfile
-
- if (#nullfile > 1 or (#nullfile > 0 and #help__ == -1))
- t: This program needs to change disks so that the $filespec
- t: $program\file is accessible, but it is not safe to do so because
- t: one or more files are open.
- t:
-
- if ($topic <> "")
- explain($topic)
- else
- t: The program must terminate immediately. Please report this
- t: message to the program's author.
- endif
- foot
- bye
- endif
- endif
- t: This program needs access to the $program\file $filespec.
- t: If you can change disks without removing any of your data files, please
- t: do so now. Otherwise, exit by typing Ctrl-C and rearrange your disks
- t: so $filespec is available when this program is run.
- t:
-
- if (#help__ >= 0)
- close #help__
- #help__ = -1
- #reopen_help = 1
- endif
- kbflush()
- foot Press ENTER when you have changed disks.
- endloop
-
- if (#reopen_help)
- reopen_help__()
- endif
-
- endproc
-
- ; ----------------------------------------------------------
- ; mount_file ensure the named file is accessible in current directory
-
- proc mount_file($filespec,$topic)
-
- mount_file__($filespec,.NO,$topic)
-
- endproc
-
- ; ------------------------------------------------------------
- ; reopen_help__ reopen help file after disk change
-
- proc reopen_help__()
-
- if (*existf($helpfile__))
- #help__ = *open($helpfile__)
- else
- t:*chr(7)
- t:The help-file for this program was on the disk you removed. You have
- t:successfully changed disks, and the program should operate properly.
- t:However, help information will no longer be available when you type '?'.
- t:
- $helpfile__=
- kbflush()
- foot
- endif
-
- endproc
-
-